#!/usr/bin/perl

use strict;
use warnings;
use Tk;
use Tk::Canvas;

# ========================================================================
# Package Rgf;
#
# Methods and constructors for reading Rgf files and exporting the data
# as separate lines or as polygons.
# ========================================================================
{
   package Rgf;

   use strict;
   use warnings;

=head1 read

Reads an rgf file and creates a new Rgf object.

=cut
   sub read {
      my $package  = shift;
      my $rgf_file = shift;

      if (! -f $rgf_file) {
         return;
      }
      my %rgf_data;
      my $line;
      open (RGF, "<$rgf_file");
      
      $rgf_data {'id'} = <RGF>;
   
      # read the identification
      while ($line = <RGF>) {
         last if $line !~ m/^\*/;
         $rgf_data {'id'} .= $line;
      }
      print(STDERR "Read rgf grid file with ID:\n", $rgf_data {'id'});
   
      chomp ($line);
   
      if ($line =~ m/Coordinate System *= *(\w+)/) {
         $rgf_data {'coordinate_system'} = $1;
         chomp ($line = <RGF>);
      }
      
      # read the number of coordinates and parts
      my ($n_zeta, $n_eta, $n_parts) = split(' ', $line);
   
      @rgf_data { ('n_zeta', 'n_eta', 'n_parts') } =
         ($n_zeta, $n_eta, $n_parts);
      
      $n_parts = 1 unless defined $n_parts;

      print("$n_zeta, $n_eta, $n_parts\n");

      # read the x0, y0 and z0 (?)
      chomp ($line = <RGF>);
      my ($x0, $y0, $z0) = split (' ', $line);
   
      @rgf_data { ('x0', 'y0', 'z0') } = ($x0, $y0, $z0);
   
      my $parts = {}; # where part info gets stored
   
      # read part info if there are parts
      if ($n_parts > 1) {
         for my $part (1..$n_parts) {
            read_part_info($parts);
         }
         $rgf_data {'parts'} = $parts;
      }
   
      # read the coordinates; first x, then y
   
      $rgf_data {'x'} = read_coordinates($n_eta, $n_zeta);
      $rgf_data {'y'} = read_coordinates($n_eta, $n_zeta); 
      
      # read y
      close (RGF);
   
      $rgf_data {'dumval'} = 0.0;
      $rgf_data {'dumacc'} = 1.0e-3;
   
      return bless (\%rgf_data, $package);
      
   }
   
   sub read_part_info {
      my $parts = shift;
      my $line = <RGF>;
      chomp ($line);
      my (undef, $part) = split (' ', $line);
      $line = <RGF>;
      chomp ($line);
      my ($m0, $mmax, $n0, $nmax) = split (' ', $line);
      $parts -> {$part} -> {'m0'}   = $m0;
      $parts -> {$part} -> {'mmax'} = $mmax;
      $parts -> {$part} -> {'n0'}   = $n0;
      $parts -> {$part} -> {'nmax'} = $nmax;
      return;
   }
   
   sub read_coordinates {
      my ($n_eta, $n_zeta) = @_;
      my @c;   # coordinates;
      my $eta;
      my $line;
      for my $eta (1..$n_eta) {
         my @c_zeta;
         chomp ($line = <RGF>);
         my ($e) = $line =~ m/eta *= *(\d+|\*\*\*)/i;
         unless ($e) {
            print(STDERR "Warning: eta could not be read.\n");
         }
         $line =~ s/eta *= *(\d+|\*\*\*)//i; # wipe the eta definition
         push (@c_zeta, split (' ', $line));
   
         # read the rest of the entries
         while (@c_zeta < $n_zeta) {
            $line = <RGF>;
            chomp ($line);
            push (@c_zeta, split (' ',$line));
         }
         $c[$eta - 1] = \@c_zeta;
      }
      return \@c;
   }
   
   sub isdummy {
      my $self = shift;
      my $value = shift;
   
      return (abs ($value - $self -> {'dumval'}) < $self -> {'dumacc'});
   }
   
   sub find_extents {
      my $self = shift;
      my $n_zeta = $self -> {'n_zeta'};
      my $n_eta  = $self -> {'n_eta'};
   
      my ($min_x, $min_y, $max_x, $max_y);
      # initialize the extents to the first values
   
      for my $e (0..$n_eta-1) {
         for my $z (0..$n_zeta - 1) {
            my $x = $self -> {'x'} -> [$e] -> [$z];
            my $y = $self -> {'y'} -> [$e] -> [$z];
   
            next if (isdummy ($self, $x) || isdummy($self, $y));
   
            if (! defined $min_x || $x < $min_x) {
               $min_x = $x;
            }
            if (! defined $max_x || $x > $max_x) {
               $max_x = $x;
            }
            if (! defined $min_y || $y < $min_y) {
               $min_y = $y;
            }
            if (! defined $max_y || $y > $max_y) {
               $max_y = $y;
            }
         }
      }
   
      $self -> {'min_x'} = $min_x;
      $self -> {'max_x'} = $max_x;
      $self -> {'min_y'} = $min_y;
      $self -> {'max_y'} = $max_y;
   
      return;
   }
   
   sub polygons {
      my $self = shift;
      my @polygons;
   
      for my $e (0..$self -> {'n_eta'}-2) {
   
         my @vertices;
   
         for my $z (0..$self -> {'n_zeta'} - 2) {
   
            my $x0 = $self -> {'x'} -> [$e] -> [$z];
            my $y0 = $self -> {'y'} -> [$e] -> [$z];
   
            next if (&isdummy ($self, $x0) || &isdummy ($self, $y0));
   
            my $x1 = $self -> {'x'} -> [$e + 1] -> [$z];
            my $y1 = $self -> {'y'} -> [$e + 1] -> [$z];
   
            next if (&isdummy ($self, $x1) || &isdummy ($self, $y1));
   
            my $x2 = $self -> {'x'} -> [$e + 1] -> [$z + 1];
            my $y2 = $self -> {'y'} -> [$e + 1] -> [$z + 1];
   
            next if (&isdummy ($self, $x2) || &isdummy ($self, $y2));
   
            my $x3 = $self -> {'x'} -> [$e] -> [$z + 1];
            my $y3 = $self -> {'y'} -> [$e] -> [$z + 1];
   
            next if (&isdummy ($self, $x3) || &isdummy ($self, $y3));
   
            
            push (@polygons, {
               'm' => $e + 1,
               'n' => $z + 1,
               'vertices' => [
                  $x0, $y0,
                  $x1, $y1,
                  $x2, $y2,
                  $x3, $y3,
               ]
            } );
         }
      }
      return @polygons;
   }
   
   sub polylines {
      my $self = shift;
      my @polylines;
   
      # iso-eta lines
      for my $e (0..$self -> {'n_eta'}-1) {
         my $vertices = [];
         for my $z (0..$self -> {'n_zeta'}-1) {
            my $x0 = $self -> {'x'}[$e][$z];
            my $y0 = $self -> {'y'}[$e][$z];
            if ($self->isdummy($x0) || $self->isdummy($y0)) {
               if (@$vertices>=4)  { # only add lines with more than 1 point
                  push(@polylines, {
                          'm' => $e+1,
                          'n' => 0,
                          'vertices' => $vertices,
                       }
                  );
               }
               $vertices = [];
            }
            else {
               push(@$vertices, $x0, $y0);
            }
         }
         if (@$vertices>=4) {
            push(@polylines, {
                    'm' => $e+1,
                    'n' => 0,
                    'vertices' => $vertices,
                 }
            );
         }
      }
   
      # iso-zeta lines
      for my $z (0..$self -> {'n_zeta'}-1) {
         my $vertices = [];
            for my $e (0..$self -> {'n_eta'}-1) {
   
            my $x0 = $self -> {'x'}[$e][$z];
            my $y0 = $self -> {'y'}[$e][$z];
            if ($self->isdummy($x0) || $self->isdummy($y0)) {
               if (@$vertices>=4)  { # only add lines with more than 1 point
                  push(@polylines, {
                          'm' => undef,
                          'n' => $z+1,
                          'vertices' => $vertices,
                       }
                  );
               }
               $vertices = [];
            }
            else {
               push(@$vertices, $x0, $y0);
            }
         }
         if (@$vertices>=4) {
            push(@polylines, {
                    'm' => undef,
                    'n' => $z+1,
                    'vertices' => $vertices,
                 }
            );
         }
      }
      return @polylines;
   }
   
   1; # module OK
   
} # end module RGF

# ========================================================================
# Package Box
#
# Routines for reading data in Simona Box format.
# ========================================================================
{
   
   package Box;
   
   use strict;
   use warnings;
   
   
   sub parse_box {
      my $package = shift;
   
      my ($min_value, $max_value);
      my @values;
      my $line;
      while (@_) {  
         do {
            $line = shift @_;
   
          }
         until $line =~ m/BOX:? +MNMN *= *\( *(\d+), *(\d+); *(\d+), *(\d+)\)/;
         my ($m_min, $n_min, $m_max, $n_max) = ($1, $2, $3, $4);
   
         for my $m ($m_min..$m_max) {
   
            $line = shift @_;
            chomp $line;
            my @tokens = split (' ', $line);
            if ($n_max-$n_min + 1 != @tokens) {
               die ("the number of numbers in the box was incorrect.");
            }
            for my $n ($n_min..$n_max) {
               $values[$m-1] -> [$n-1] = shift @tokens;
               if ( (defined $min_value && $values[$m-1] < $min_value) ||
                    ! defined $min_value ) {
                  $min_value = $values[$m-1];
               }
               if ( (defined $max_value && $values[$m-1] > $max_value) ||
                    ! defined $max_value ) {
                  $max_value = $values[$m-1];
               }
            }
         }
      }
      my $self = {'values'     => \@values,
                  'min_value'  => $min_value,
                  'max_value'  => $max_value,
      };
   
      return bless $self, $package;
   }
   
   sub parse_file {
      my $package = shift;
      my $filename = shift;
      open(BOX, "<$filename");
      my @lines = <BOX>;
      close (BOX);
      return $package -> parse_box(@lines);
   }
   
   sub values {
      my $self = shift;
      return @{ $self -> {'values'} };
   }
   
   sub max {
      my $self = shift;
      return $self -> {'max_value'};
   }
   
   sub min {
      my $self = shift;
      return $self -> {'min_value'};
   }
   
            
   # module OK
   1;

} # end module Box

# ========================================================================
# Transformations
#
# Defines transformation from model space to screen space and vice versa.
# ========================================================================
{
   package Transformation;
   use strict;
   use warnings;

   sub new {
      my $package = shift;
      my ($x_r_o,
          $y_r_o,
          $scale,
          $s_width,
          $s_height) = @_;

      my $self = { 'x_r_o'         => $x_r_o,
                   'y_r_o'         => $y_r_o,
                   'scale'         => $scale,
                   's_width'       => $s_width,
                   's_height'      => $s_height,
      };
      return bless ($self, $package);
   }
   
   sub set {
      my $self = shift;
      my %options = @_;
      for my $option (keys %options) {
         $self -> {$option} = $options{$option};
      }
   }
 
   sub real_to_screen {
      # return values: x and y in screen space
      my ($x_s, $y_s);
      if (ref $_[0]) {
         # object method
         my ($self, $x_r, $y_r) = @_;

         $x_s = $self->{'s_width'}  / 2 +
                   ($x_r - $self->{'x_r_o'}) * $self->{'scale'};
         $y_s = $self->{'s_height'} / 2 - 
                   ($y_r - $self->{'y_r_o'}) * $self->{'scale'};
      }
      else {
         # class method
         my ($x_r, $y_r, $x_r_o, $y_r_o, $scale, $s_width, $s_height) = @_;
         $x_s = $s_width  / 2 + ($x_r - $x_r_o) * $scale;
         $y_s = $s_height / 2 - ($y_r - $y_r_o) * $scale;
      }

      return ($x_s, $y_s);
   }

   sub screen_to_real {
      # return values: x and y in model space
      my ($x_r, $y_r);
      if (ref $_[0]) {
         # object method
         my ($self, $x_s, $y_s) = @_;
         
         $x_r = $self->{'x_r_o'} +
                   ($x_s-$self->{'s_width'}/2) / $self->{'scale'};
         $y_r = $self->{'y_r_o'} -
                   ($y_s-$self->{'s_height'}/2) / $self->{'scale'};
      }
      else {
         die("Transform::screen to real not implemented");
      }
      return ($x_r, $y_r);
   }

   # module OK
   1;   
} # end package Transformation


# ========================================================================
# Package Control
#
# Logic layer between the data and the view.
# ========================================================================
{
   package Control;
   use Tk;
   use strict;
   use warnings;

   # ---------------------------------------------------------------------
   # Contructor
   # ---------------------------------------------------------------------
   sub new {
      my $package = shift;
      my $rgf     = shift; # the data object
      my $canvas  = shift; # the view object
   
      my $s_width  = $canvas -> cget('width');
      my $s_height = $canvas -> cget('height');

      my @polylines = $rgf -> polylines();

      my $self = {
         'polylines'      => \@polylines,

         'rgf'            => $rgf,
         'canvas'         => $canvas,
         # view parameters
         'x_r_o'          => undef,
         'y_r_o'          => undef,
         'scale'          => undef,

         's_width'        => undef,
         's_height'       => undef,

         'pad_x'          => 10, # default values for padding
         'pad_y'          => 10,

         'transformation' => undef,

         # zoom parameters
         'zoom_state'     => 'inactive', # value    : meaning
                                         # inactive : inactive
                                         # started  : button clicked but no box
                                         # active   : box showing

         # zoom box coordinates in screen space
         'x_zb_0'         => undef,
         'y_zb_0'         => undef,
         'x_zb_1'         => undef,
         'y_zb_1'         => undef,

      };
      return bless ($self, $package);
   }

   # ---------------------------------------------------------------------
   # Zoom a region, but keep the right aspect ratio correct
   # ---------------------------------------------------------------------
   sub zoom_region {
      my $self = shift;
      my ($x_r_min,
          $y_r_min,
          $x_r_max,
          $y_r_max,
      ) = @_;

      my $pad_x = $self -> {'pad_x'};
      my $pad_y = $self -> {'pad_y'};

      my $s_width  = $self -> {'canvas'} -> cget('-width');
      my $s_height = $self -> {'canvas'} -> cget('-height');

      my $scale_x = ( $s_width - 2 * $pad_x ) / 
         ( $x_r_max - $x_r_min );

      my $scale_y = ( $s_height - 2 * $pad_y ) /
         ($y_r_max - $y_r_min);

      $self -> {'scale'} = min ($scale_x, $scale_y);

      $self -> {'x_r_o'} = ($x_r_max + $x_r_min) / 2;
      $self -> {'y_r_o'} = ($y_r_max + $y_r_min) / 2;

      $self -> {'transformation'} =
         new Transformation($self -> {'x_r_o'},
                            $self -> {'y_r_o'},
                            $self -> {'scale'},
                            $s_width,
                            $s_height);

      return;
   }

   # ---------------------------------------------------------------------
   # View the entire dataset
   # ---------------------------------------------------------------------
   sub zoom_all {
      my $self = shift;

      my $rgf = $self -> {'rgf'};

      $rgf -> find_extents();

      $self -> zoom_region($rgf -> {'min_x'},
                           $rgf -> {'min_y'},
                           $rgf -> {'max_x'},
                           $rgf -> {'max_y'}
      );
      return;
   }

   sub min {
      my ($v1, $v2) = @_;
      return $v1 < $v2 ? $v1 : $v2;
   }

   # ---------------------------------------------------------------------
   # Draw all polylines
   # ---------------------------------------------------------------------
   sub draw_polylines {
      my $self = shift;

      my $polygons_ref   = $self -> {'polylines'};
      my $transformation = $self -> {'transformation'};
      my $canvas         = $self -> {'canvas'};
   
      my $outline = 'black';
   
      foreach my $polygon ( @{ $polygons_ref } ) {
   
         my $m = $polygon -> {'m'};
         my $n = $polygon -> {'n'};

         # vertices in model space
         my @r_vertices = @{ $polygon -> {'vertices'} };

         # vertices in screen space
         my @s_vertices;
   
         # transform the model polygon to screen polygons
         while (@r_vertices) {
            my $x_r = shift @r_vertices;
            my $y_r = shift @r_vertices;
   
            # transform
            my ($x_s, $y_s) = $transformation -> real_to_screen ($x_r, $y_r);
            push(@s_vertices, $x_s, $y_s);
         }
               
         my $color = undef;
         my $id = $canvas -> createLine (@s_vertices, 
   #                                         -fill => $color,
   #                                         -outline => $outline, 
                                            -width => 1);
   
      #   $canvas -> bind ($id, '<1>' => [\&select_cell, $m + 2, $n + 2]);
      } # foreach polygon
#      $canvas -> update();
#
      return;
   }

   # ------------------------------------------------------------------------
   # Callback implementations
   # ------------------------------------------------------------------------

   sub zoom_callback {
      my $self = shift;

      # initialise zooming

      # initialise the canvas events
      my $can = $self -> {'canvas'};
      $can->CanvasBind('<1>' => [$self => 'zoom', Ev('x'), Ev('y')]);
      $self -> {'zoom_state'} = 'started';
      return;
   }

   sub zoomall_callback {
      my $self = shift;
      
      $self -> zoom_all();

      $self -> {'canvas'} -> delete('all');

      $self -> {'canvas'} -> configure(-cursor => 'watch');
      $self -> draw_polylines();
      $self -> {'canvas'} -> configure(-cursor => 'crosshair');


      # reset the zoom box and parameters
      $self -> {'zoombox_id'} = undef;
      $self -> {'x_zb_0'}     = undef;
      $self -> {'y_zb_0'}     = undef;
      $self -> {'x_zb_1'}     = undef;
      $self -> {'y_zb_1'}     = undef;
      $self -> {'zoom_state'} = 'inactive';
      
      return;
   }

   # ---------------------------------------------------------------------
   # Canvas callback implementations
   # ---------------------------------------------------------------------

   sub zoom {
      my $self = shift;
      my $x = shift;
      my $y = shift;

      if ($self -> {'zoom_state'} eq 'started') {
         # start drawing the zoom box
         $self -> {'x_zb_0'} = $x;
         $self -> {'y_zb_0'} = $y;

         $self -> {'x_zb_1'} = $x;
         $self -> {'y_zb_1'} = $y;

         $self -> {'zoombox_id'} =
            $self -> {'canvas'} -> createRectangle($x, $y,
                                                   $x, $y,
                                                   -dash => '-');
         $self -> {'canvas'} -> 
            CanvasBind('<Motion>' => [$self => 'motion',Ev('x'),Ev('y')]);

         $self -> {'zoom_state'} = 'active';
      }
      elsif ($self -> {'zoom_state'} eq 'active') {
         # stop zooming;
         
         # find the model coordinates of the zoom box
         my ($x_r_0, $y_r_0) =
            $self->{'transformation'}->screen_to_real($self->{'x_zb_0'},
                                                      $self->{'y_zb_0'});
         my ($x_r_1, $y_r_1) =
            $self->{'transformation'}->screen_to_real($self->{'x_zb_1'},
                                                      $self->{'y_zb_1'});
         
         if ($y_r_1 < $y_r_0) {
            # upside-down; flip
            ($y_r_0, $y_r_1) = ($y_r_1, $y_r_0);
         }

         $self -> zoom_region($x_r_0, $y_r_0, $x_r_1, $y_r_1);

         $self -> {'canvas'} -> configure(-cursor => 'watch');

         $self -> {'canvas'} -> delete('all');

         $self -> draw_polylines();

         $self -> {'canvas'} -> configure(-cursor => 'crosshair');

         # reset the zoom box and parameters
         $self -> {'zoombox_id'} = undef;
         $self -> {'x_zb_0'}     = undef;
         $self -> {'y_zb_0'}     = undef;
         $self -> {'x_zb_1'}     = undef;
         $self -> {'y_zb_1'}     = undef;
         $self -> {'zoom_state'} = 'inactive';

         # remove the canvas button and motion binding
#         $self -> {'canvas'} -> 
      }
      return;
   }

   sub motion {
      my $self = shift;
      my $x    = shift;
      my $y    = shift;

      # find out what needs to be done
      if ($self -> {'zoom_state'} eq 'active') {
         # the zoom box needs to be moved
         $self -> {'x_zb_1'} = $x;
         $self -> {'y_zb_1'} = $y;
         $self -> {'canvas'} -> coords($self -> {'zoombox_id'},
                                       $self -> {'x_zb_0'},
                                       $self -> {'y_zb_0'},
                                       $self -> {'x_zb_1'},
                                       $self -> {'y_zb_1'}
         );
      }

      return;
   }
 

   # module OK
   1;
}

   
# ========================================================================
# Main program
# ========================================================================

use strict;
use warnings;

# process cmd line arguments; 
my $rgf_file = $ARGV[0];

unless (defined $rgf_file && -f $rgf_file) {
   print("Use:\n",
         "   readRgf.pl <TELMACRGF file> [bottom file [scale]]\n",
         "\n",
         "Bottom is positive downward; use a negative scale if bottom is ",
         "positive upward.\n");
   exit;
}

my (@bottom, $z0, $zfact); # zfact

if (defined $ARGV[1]) {
   my $bottom_box = Box -> parse_file ($ARGV[1]);
   @bottom = $bottom_box -> values(); 
   $zfact = $ARGV[2] || 1.0;

   if (defined $ARGV[2] && $ARGV[2] > 0) {

      if ($bottom_box-> min() < 0) {
         # bottom positive is downward; probably sea model
         $zfact = 255 / $bottom_box -> max();
         $z0    = 0.0;
      }
      else {
         # strange sea model (without land?)
         $zfact = 255 / ($bottom_box -> max() - $bottom_box -> min() );
         $z0    = $bottom_box -> min();
      }
   }
#   else {
#      # bottom positive is upward; probably river model
#      if ($bottom_box -> max() 

}

# ------------------------------------------------------------------------
# Variable declarations, default values
# ------------------------------------------------------------------------
# 
# Screen parameters
my $s_width  = 800;
my $s_height = 600;

my $pad_x = 20;
my $pad_y = 20;

# the zooming of the screen is defined by the coordinates of the 
# origin in model space and a scale factor; 
my ($x_r_o, $y_r_o, $scale);

# the state of the canvas
my $zoom_state = { 'x_0'   => undef,
                   'y_0'   => undef,
                   'x_1'   => undef,
                   'y_1'   => undef,
};



# ------------------------------------------------------------------------
# start program
# ------------------------------------------------------------------------
# read the rgf file, create an rgf object

my $rgf = Rgf -> read ($rgf_file);

printf("(done reading rgf file)\n");

# ------------------------------------------------------------------------
# Lay-out the graphical user interface components
# ------------------------------------------------------------------------

# the controller needs the screen width on initialisation, so add the
# bindings after the controller has been created, after the canvas has
# been packed

my $mw = new MainWindow (-title => $rgf_file);

my $canvas = $mw -> Scrolled('Canvas',
                           -width  => $s_width,
                           -height => $s_height,
                           -scrollregion =>  [0,0,$s_width,$s_height],
                          );
$canvas -> configure(-cursor => 'crosshair');

$canvas -> pack(-side   => 'bottom',
                -fill   => 'both',
                -expand => 0);

# Create the zoom buttons on the zoom frame

my $button_frame = $mw -> Frame();

my $zoom_button  = $button_frame -> Button (-text => 'Zoom');
$zoom_button -> pack(-side => 'left');

my $zoomall_button = $button_frame -> Button (-text => 'Zoom all');
$zoomall_button -> pack(-side  => 'left',
                        -after => $zoom_button);

$button_frame -> pack(-side => 'top',
                      -fill => 'x');

# define the controller, which depends on the size of the canvas

my $control = new Control($rgf, $canvas);

# ------------------------------------------------------------------------
# Attach commands to the buttons
#------------------------------------------------------------------------

$zoom_button -> configure(-command => sub { $control -> zoom_callback() } );
$zoomall_button -> configure(-command => [$control => "zoomall_callback"]);
 


# ------------------------------------------------------------------------
# Initialize the first view as a zoom all, then start the event loop
# ------------------------------------------------------------------------

$control -> zoom_all();

$control -> draw_polylines();



MainLoop();


sub select_cell {
   my (undef, $m, $n) = @_;
#   print "Selected: $m, $n\n";
   return;
}

sub min {
   my ($a, $b) = @_;
   return $a < $b ? $a : $b;
}


